More expected language dialog behavior wrt keyboard use
svn: r4759
This commit is contained in:
Eli Barzilay
parent
e69c62efde
commit
21a4ed332e
|
|
@ -139,7 +139,7 @@
|
|||
(define/override (on-subwindow-char receiver evt)
|
||||
(case (send evt get-key-code)
|
||||
[(escape) (cancel-callback)]
|
||||
[(#\return numpad-enter) (ok-callback)]
|
||||
[(#\return numpad-enter) (enter-callback)]
|
||||
[else (super on-subwindow-char receiver evt)]))
|
||||
(super-instantiate ())))
|
||||
|
||||
|
|
@ -162,34 +162,6 @@
|
|||
(parent dialog)
|
||||
(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-values (ok-button cancel-button)
|
||||
(gui-utils:ok/cancel-buttons
|
||||
|
|
@ -198,6 +170,39 @@
|
|||
(λ (x y) (cancel-callback))))
|
||||
(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?
|
||||
(add-welcome dialog welcome-before-panel welcome-after-panel))
|
||||
|
||||
|
|
@ -214,13 +219,13 @@
|
|||
(get-selected-language-settings)))))
|
||||
|
||||
;; 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])
|
||||
;; 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
|
||||
;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd.
|
||||
(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)
|
||||
(let ([request-lang-to-show (language-settings-language language-settings-to-show)])
|
||||
|
|
@ -245,89 +250,84 @@
|
|||
(inherit get-selected)
|
||||
(define/override (on-char evt)
|
||||
(let ([code (send evt get-key-code)])
|
||||
(cond
|
||||
[(eq? code 'up) (select-next sub1 (λ (v) (- (vector-length v) 1)))]
|
||||
[(eq? code 'down) (select-next add1 (λ (v) 0))]
|
||||
(case code
|
||||
[(up) (select-next sub1)]
|
||||
[(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)])))
|
||||
|
||||
(inherit get-items)
|
||||
|
||||
;; select-next : (int -> int) (vector -> int)
|
||||
;; finds the next leaf after the selected child,
|
||||
;; using `inc' and `start' to control the direction of the traversal.
|
||||
(define/private (select-next inc start)
|
||||
(define fst-selected (get-selected))
|
||||
(let loop ([item fst-selected])
|
||||
(when item
|
||||
(let* ([parent (send item get-parent)]
|
||||
[siblings (if parent
|
||||
(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)))))))
|
||||
;; select-next : (num -> num) -> void
|
||||
;; finds the next/prev leaf after the selected child on the open
|
||||
;; fringe using `inc' for a direction.
|
||||
(define/private (select-next inc)
|
||||
(define current (get-selected))
|
||||
(define (choose item)
|
||||
(when current (send current select #f))
|
||||
(send item select #t)
|
||||
;; make it visible
|
||||
(let loop ([item item])
|
||||
(let ([parent (send item get-parent)])
|
||||
(if parent
|
||||
(loop parent)
|
||||
(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))))))))
|
||||
|
||||
;; 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 ([parent (send item get-parent)])
|
||||
(if parent
|
||||
(loop parent)
|
||||
(send item scroll-to))))
|
||||
(send item scroll-to))
|
||||
(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)
|
||||
(cond
|
||||
[(and i (is-a? i hieritem-language<%>))
|
||||
(send i selected)]
|
||||
[else
|
||||
(nothing-selected)]))
|
||||
(if (and i (is-a? i hieritem-language<%>))
|
||||
(something-selected)
|
||||
(nothing-selected)))
|
||||
;; this is not used, since all lists are selectable
|
||||
(define/override (on-click i)
|
||||
(when (and i (is-a? i hierarchical-list-compound-item<%>))
|
||||
(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))))
|
||||
|
||||
(define outermost-panel (make-object horizontal-pane% parent))
|
||||
|
|
@ -394,7 +394,14 @@
|
|||
(send details-panel active-child no-details-panel)
|
||||
(send one-line-summary-message set-label "")
|
||||
(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
|
||||
;; updates the manual ordering text with the order the manuals are searched for this language
|
||||
|
|
@ -478,6 +485,7 @@
|
|||
(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"
|
||||
positions numbers))
|
||||
(send languages-hier-list clear-fringe-cache)
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -599,7 +607,7 @@
|
|||
(send new-list set-number number)
|
||||
(when 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 (send new-list get-editor) insert position)
|
||||
(hash-table-put! ht (string->symbol position) x)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user