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

Misc reformatting, mostly using new stuff that make things easier.

Browse Source 
svn: r10286
This commit is contained in:
Eli Barzilay 2008-06-16 14:42:14 +00:00
parent 86cdf405ee
commit 495588eabf
1 changed files with 120 additions and 155 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -23,74 +23,50 @@
(define format-handlers '()) (define format-handlers '())
(define make-insert-handler (define (make-insert-handler who name extension handler)
(letrec ([string-list? (cond [(not (string? name))
(λ (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")] (error who "name was not a string")]
[(and (not (procedure? extension)) [(not (or (procedure? extension)
(not (string? extension)) (string? extension)
(not (string-list? extension))) (and (list? extension) (andmap string? extension))))
(error who (error who
"extension was not a string, list of strings, or a predicate")] "extension was not a string, list of strings, or a predicate")]
[(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
(if (string? extension) (if (string? extension) (list extension) extension)
(list extension) handler)]))
extension)
handler)]))))
(define insert-format-handler (define (insert-format-handler . args)
(λ args
(set! format-handlers (set! format-handlers
(cons (apply make-insert-handler 'insert-format-handler args) (cons (apply make-insert-handler 'insert-format-handler args)
format-handlers)))) format-handlers)))
(define find-handler (define (find-handler name handlers)
(λ (name handlers)
(let/ec exit (let/ec exit
(let ([extension (if (string? name) (let ([extension (if (string? name) (or (filename-extension name) "") "")])
(or (filename-extension name) (for ([handler handlers])
"")
"")])
(for-each
(λ (handler)
(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 (pair? ext) (and (pair? ext)
(ormap (λ (ext) (string=? ext extension)) (ormap (λ (ext) (string=? ext extension))
ext))) ext)))
(exit (handler-handler handler))))) (exit (handler-handler handler)))))
handlers) #f)))
#f))))
(define find-format-handler (define (find-format-handler name)
(λ (name) (find-handler name format-handlers))
(find-handler name format-handlers)))
; Finding format & mode handlers by name ; Finding format & mode handlers by name
(define find-named-handler (define (find-named-handler name handlers)
(λ (name handlers)
(let loop ([l handlers]) (let loop ([l handlers])
(cond (cond [(null? l) #f]
[(null? l) #f]
[(string-ci=? (handler-name (car l)) name) [(string-ci=? (handler-name (car l)) name)
(handler-handler (car l))] (handler-handler (car l))]
[else (loop (cdr l))])))) [else (loop (cdr l))])))
(define find-named-format-handler (define (find-named-format-handler name)
(λ (name) (find-named-handler name format-handlers))
(find-named-handler name format-handlers)))
; Open a file for editing ; Open a file for editing
(define current-create-new-window (define current-create-new-window
@ -100,13 +76,8 @@
(send frame show #t) (send frame show #t)
frame)))) frame))))
(define edit-file (define (edit-file filename [make-default
(case-lambda (λ () ((current-create-new-window) filename))])
[(filename) (edit-file
filename
(λ ()
((current-create-new-window) filename)))]
[(filename make-default)
(with-handlers ([(λ (x) #f) ;exn:fail? (with-handlers ([(λ (x) #f) ;exn:fail?
(λ (exn) (λ (exn)
(message-box (message-box
@ -140,15 +111,11 @@
(send fr show #t) (send fr show #t)
fr)] fr)]
[else [else
(let ([handler (let ([handler (and (path? filename)
(if (path? filename) (find-format-handler filename))])
(find-format-handler filename)
#f)])
(add-to-recent filename) (add-to-recent filename)
(if handler (if handler (handler filename) (make-default)))]))
(handler filename) (make-default))))))
(make-default)))]))
(make-default)))))]))
;; type recent-list-item = (list/p string? number? number?) ;; type recent-list-item = (list/p string? number? number?)
@ -164,28 +131,25 @@
[new-ent (list filename [new-ent (list filename
(if old-ent (cadr old-ent) 0) (if old-ent (cadr old-ent) 0)
(if old-ent (caddr old-ent) 0))] (if old-ent (caddr old-ent) 0))]
[added-in (cons new-ent (remove new-ent old-list compare-recent-list-items))] [added-in (cons new-ent
[new-recent (size-down added-in (preferences:get 'framework:recent-max-count))]) (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))) (preferences:set 'framework:recently-opened-files/pos new-recent)))
;; 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=? (path->string (car l1)) (equal? (car l1) (car l2)))
(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
;; front of the list, up to `recent-max-count' items ;; front of the list, up to `recent-max-count' items
(define (size-down new-recent n) (define (size-down new-recent n)
(let loop ([n n] (let loop ([n n] [new-recent new-recent])
[new-recent new-recent]) (cond [(zero? n) null]
(cond
[(zero? n) null]
[(null? new-recent) null] [(null? new-recent) null]
[else [else (cons (car new-recent)
(cons (car new-recent) (loop (- n 1) (cdr new-recent)))])))
(loop (- n 1)
(cdr new-recent)))])))
;; size-recently-opened-files : number -> void ;; size-recently-opened-files : number -> void
;; sets the recently-opened-files/pos preference ;; sets the recently-opened-files/pos preference
@ -295,24 +259,24 @@
(define/private (refresh-hl recent-list-items) (define/private (refresh-hl recent-list-items)
(let ([ed (send hl get-editor)]) (let ([ed (send hl get-editor)])
(send ed begin-edit-sequence) (send ed begin-edit-sequence)
(for-each (λ (item) (send hl delete-item item)) (send hl get-items)) (for ([item (send hl get-items)]) (send hl delete-item item))
(for-each (λ (item) (add-recent-item item)) (for-each (λ (item) (add-recent-item item))
(if (eq? (preferences:get 'framework:recently-opened-sort-by) 'name) (if (eq? (preferences:get 'framework:recently-opened-sort-by)
(sort recent-list-items 'name)
(λ (x y) (string<=? (path->string (car x)) (sort recent-list-items string<?
(path->string (car y))))) #:key (compose path->string car) #:cache-keys? #t)
recent-list-items)) recent-list-items))
(send ed end-edit-sequence))) (send ed end-edit-sequence)))
(define/private (add-recent-item recent-list-item) (define/private (add-recent-item recent-list-item)
(let ([item (send hl new-item (make-hierlist-item-mixin recent-list-item))]) (let ([item (send hl
(send (send item get-editor) insert (path->string (car recent-list-item))))) 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 (field [remove-prefs-callback
(preferences:add-callback (preferences:add-callback 'framework:recently-opened-files/pos
'framework:recently-opened-files/pos (λ (p v) (refresh-hl v)))])
(λ (p v)
(refresh-hl v)))])
(define/augment (on-close) (define/augment (on-close)
(inner (void) on-close) (inner (void) on-close)
@ -323,7 +287,8 @@
(inherit get-area-container) (inherit get-area-container)
(field [bp (make-object horizontal-panel% (get-area-container))] (field [bp (make-object horizontal-panel% (get-area-container))]
[hl (make-object recent-items-hierarchical-list% (get-area-container) '())] [hl (make-object recent-items-hierarchical-list%
(get-area-container) '())]
[sort-by-name-button [sort-by-name-button
(make-object button% (make-object button%
(string-constant recent-items-sort-by-name) (string-constant recent-items-sort-by-name)