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

More expected language dialog behavior wrt keyboard use

Browse Source 
svn: r4759
This commit is contained in:
Eli Barzilay 2006-11-03 15:13:34 +00:00
parent e69c62efde
commit 21a4ed332e
1 changed files with 118 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

210
collects/drscheme/private/language-configuration.ss
View File

@ -139,7 +139,7 @@
(define/override (on-subwindow-char receiver evt) (define/override (on-subwindow-char receiver evt)
(case (send evt get-key-code) (case (send evt get-key-code)
[(escape) (cancel-callback)] [(escape) (cancel-callback)]
[(#\return numpad-enter) (ok-callback)] [(#\return numpad-enter) (enter-callback)]
[else (super on-subwindow-char receiver evt)])) [else (super on-subwindow-char receiver evt)]))
(super-instantiate ()))) (super-instantiate ())))
@ -162,34 +162,6 @@
(parent dialog) (parent dialog)
(stretchable-height #f))) (stretchable-height #f)))
(define-values (get-selected-language get-selected-language-settings)
(fill-language-dialog language-dialog-meat-panel
button-panel
language-settings-to-show
#f
manuals?))
;; cancelled? : boolean
;; flag that indicates if the dialog was cancelled.
(define cancelled? #t)
;; ok-callback : -> void
(define (ok-callback)
(cond
[(get-selected-language)
(set! cancelled? #f)
(send dialog show #f)]
[else
(message-box (string-constant drscheme)
(string-constant please-select-a-language))]))
;; cancel-callback : -> void
(define (cancel-callback)
(send dialog show #f))
(define show-details-label (string-constant show-details-button-label))
(define hide-details-label (string-constant hide-details-button-label))
(define button-gap (make-object horizontal-pane% button-panel)) (define button-gap (make-object horizontal-pane% button-panel))
(define-values (ok-button cancel-button) (define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons (gui-utils:ok/cancel-buttons
@ -198,6 +170,39 @@
(λ (x y) (cancel-callback)))) (λ (x y) (cancel-callback))))
(define grow-box-spacer (make-object grow-box-spacer-pane% button-panel)) (define grow-box-spacer (make-object grow-box-spacer-pane% button-panel))
(define-values (get-selected-language get-selected-language-settings)
(fill-language-dialog language-dialog-meat-panel
button-panel
language-settings-to-show
#f
manuals?
ok-button))
;; cancelled? : boolean
;; flag that indicates if the dialog was cancelled.
(define cancelled? #t)
;; ok-callback : -> void
(define (ok-callback)
(cond [(get-selected-language)
(set! cancelled? #f)
(send dialog show #f)]
[else
(message-box (string-constant drscheme)
(string-constant please-select-a-language))]))
;; enter-callback : -> void similar to the above, but return #f if no
;; language is selected, so the event will be processed by the list
;; (which will toggle subtrees)
(define (enter-callback)
(cond [(get-selected-language)
(set! cancelled? #f)
(send dialog show #f)]
[else #f]))
;; cancel-callback : -> void
(define (cancel-callback)
(send dialog show #f))
(when show-welcome? (when show-welcome?
(add-welcome dialog welcome-before-panel welcome-after-panel)) (add-welcome dialog welcome-before-panel welcome-after-panel))
@ -214,13 +219,13 @@
(get-selected-language-settings))))) (get-selected-language-settings)))))
;; fill-language-dialog : (vertical-panel panel language-setting -> language-setting) ;; fill-language-dialog : (vertical-panel panel language-setting -> language-setting)
;; (union dialog #f) ;; (union dialog #f) [...more stuff...]
;; -> (-> (union #f language<%>)) (-> settings[corresponding to fst thnk result]) ;; -> (-> (union #f language<%>)) (-> settings[corresponding to fst thnk result])
;; allows the user to configure their language. The input language-setting is used ;; allows the user to configure their language. The input language-setting is used
;; as the defaults in the dialog and the output language setting is the user's choice ;; as the defaults in the dialog and the output language setting is the user's choice
;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd. ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd.
(define fill-language-dialog (define fill-language-dialog
(opt-lambda (parent show-details-parent language-settings-to-show [re-center #f] [manuals? #f]) (opt-lambda (parent show-details-parent language-settings-to-show [re-center #f] [manuals? #f] [ok-button #f])
(define-values (language-to-show settings-to-show) (define-values (language-to-show settings-to-show)
(let ([request-lang-to-show (language-settings-language language-settings-to-show)]) (let ([request-lang-to-show (language-settings-language language-settings-to-show)])
@ -245,89 +250,84 @@
(inherit get-selected) (inherit get-selected)
(define/override (on-char evt) (define/override (on-char evt)
(let ([code (send evt get-key-code)]) (let ([code (send evt get-key-code)])
(cond (case code
[(eq? code 'up) (select-next sub1 (λ (v) (- (vector-length v) 1)))] [(up) (select-next sub1)]
[(eq? code 'down) (select-next add1 (λ (v) 0))] [(down) (select-next add1)]
;; right key is fine, but nicer to close after a left
[(left) (super on-char evt)
(cond [(get-selected) => (λ (i) (send i close))])]
[else (super on-char evt)]))) [else (super on-char evt)])))
(inherit get-items) (inherit get-items)
;; select-next : (int -> int) (vector -> int) ;; select-next : (num -> num) -> void
;; finds the next leaf after the selected child, ;; finds the next/prev leaf after the selected child on the open
;; using `inc' and `start' to control the direction of the traversal. ;; fringe using `inc' for a direction.
(define/private (select-next inc start) (define/private (select-next inc)
(define fst-selected (get-selected)) (define current (get-selected))
(let loop ([item fst-selected]) (define (choose item)
(when item (when current (send current select #f))
(let* ([parent (send item get-parent)] (send item select #t)
[siblings (if parent ;; make it visible
(send parent get-items)
(get-items))]
[siblings-len (length siblings)])
(let sibling-loop ([index (inc (find-index item siblings))])
(if (< -1 index siblings-len)
(let ([child (find-first-leaf (list-ref siblings index)
inc start)])
(if child
(begin (send fst-selected select #f)
(send child select #t)
(open-parents child)
(make-visible child))
(sibling-loop (inc index))))
(loop parent)))))))
;; find-first-leaf : item (int -> int) (vec -> int)
;; finds the first child, using `inc' and `start' to control
;; the traversal over the children.
(define/private (find-first-leaf item inc start)
(let loop ([item item])
(cond
[(is-a? item hierarchical-list-compound-item<%>)
(let ([children (list->vector (send item get-items))])
(let child-loop ([i (start children)])
(cond
[(and (<= 0 i) (< i (vector-length children)))
(or (loop (vector-ref children i))
(child-loop (inc i)))]
[else #f])))]
[(send item get-allow-selection?)
item]
[else #f])))
;; find-index : tst (listof tst) -> int
;; returns the index of `item' in `lst'
(define/private (find-index item lst)
(let loop ([i 0] [l lst])
(cond [(null? l)
(error 'find-index "didn't find ~e in ~e" item lst)]
[(eq? (car l) item) i]
[else (loop (add1 i) (cdr l))])))
;; open-parents : item -> void
;; selects the item and opens all of its parents.
(define/private (open-parents item)
(let loop ([item (send item get-parent)])
(when item
(send item open)
(loop (send item get-parent)))))
(define/private (make-visible item)
(let loop ([item item]) (let loop ([item item])
(let ([parent (send item get-parent)]) (let ([parent (send item get-parent)])
(if parent (if parent
(loop parent) (loop parent)
(send item scroll-to)))) (send item scroll-to))))
(send item scroll-to)) (send item scroll-to))
(define (selectable? item)
(and (send item get-allow-selection?)
;; opened all the way to the top
(let loop ([p (send item get-parent)])
(or (not p)
(and (send p is-open?)
(loop (send p get-parent)))))))
(let* ([fringe (get-fringe)]
[fringe-len (vector-length fringe)]
[n (if current
(let loop ([i (sub1 (vector-length fringe))])
(cond [(< i 0) (error 'select-next "item not found in fringe")]
[(eq? current (vector-ref fringe i))
(min (sub1 fringe-len) (max 0 (inc i)))]
[else (loop (sub1 i))]))
(modulo (inc fringe-len) (add1 fringe-len)))])
;; need to choose item n, but go on looking for one that is
;; selectable and open
(let loop ([n n])
(when (< -1 n fringe-len)
(let ([item (vector-ref fringe n)])
(if (selectable? item)
(choose item)
(loop (inc n))))))))
(define cached-fringe #f)
(define/public (clear-fringe-cache) (set! cached-fringe #f))
(define (get-fringe)
(unless cached-fringe
(let ([fringe
(let loop ([items (get-items)])
(apply append
(map (λ (item)
(if (is-a? item hierarchical-list-compound-item<%>)
(cons item
(loop (send item get-items)))
(list item)))
items)))])
(set! cached-fringe (list->vector fringe))))
cached-fringe)
(define/override (on-select i) (define/override (on-select i)
(cond (if (and i (is-a? i hieritem-language<%>))
[(and i (is-a? i hieritem-language<%>)) (something-selected)
(send i selected)] (nothing-selected)))
[else ;; this is not used, since all lists are selectable
(nothing-selected)]))
(define/override (on-click i) (define/override (on-click i)
(when (and i (is-a? i hierarchical-list-compound-item<%>)) (when (and i (is-a? i hierarchical-list-compound-item<%>))
(send i toggle-open/closed))) (send i toggle-open/closed)))
;; use this instead
(define/override (on-double-select i)
(when (and i (is-a? i hierarchical-list-compound-item<%>))
(send i toggle-open/closed)))
(super-instantiate (parent)))) (super-instantiate (parent))))
(define outermost-panel (make-object horizontal-pane% parent)) (define outermost-panel (make-object horizontal-pane% parent))
@ -394,7 +394,14 @@
(send details-panel active-child no-details-panel) (send details-panel active-child no-details-panel)
(send one-line-summary-message set-label "") (send one-line-summary-message set-label "")
(set! get/set-selected-language-settings #f) (set! get/set-selected-language-settings #f)
(set! selected-language #f)) (set! selected-language #f)
(when ok-button (send ok-button enable #f))
(send details-button enable #f))
;; something-selected : -> void
(define (something-selected)
(when ok-button (send ok-button enable #t))
(send details-button enable #t))
;; update-manual-ordering-text : -> void ;; update-manual-ordering-text : -> void
;; updates the manual ordering text with the order the manuals are searched for this language ;; updates the manual ordering text with the order the manuals are searched for this language
@ -478,6 +485,7 @@
(error 'drscheme:language (error 'drscheme:language
"languages position and numbers must be lists of strings and numbers, respectively, must have the same length, and must each contain at least two elements, got: ~e ~e" "languages position and numbers must be lists of strings and numbers, respectively, must have the same length, and must each contain at least two elements, got: ~e ~e"
positions numbers)) positions numbers))
(send languages-hier-list clear-fringe-cache)
#| #|
@ -599,7 +607,7 @@
(send new-list set-number number) (send new-list set-number number)
(when second-number (when second-number
(send new-list set-second-number second-number)) (send new-list set-second-number second-number))
(send new-list set-allow-selection #f) (send new-list set-allow-selection #t)
(send new-list open) (send new-list open)
(send (send new-list get-editor) insert position) (send (send new-list get-editor) insert position)
(hash-table-put! ht (string->symbol position) x) (hash-table-put! ht (string->symbol position) x)